Main question: at this point we’re interested in one single classification, i.e. what predicts whether people do maskless contacts with non-householders

Research Document

Questions codebook

Method of delivery

sessionInfo()
R version 4.0.3 (2020-10-10)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS Big Sur 10.16

Matrix products: default
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib

locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

attached base packages:
[1] parallel  stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] rpart_4.1-15        rattle_5.4.0        bitops_1.0-7        tibble_3.0.4        doParallel_1.0.16   iterators_1.0.13    foreach_1.5.1       cvms_1.3.0         
 [9] tidyr_1.1.2         randomForest_4.6-14 caret_6.0-86        lattice_0.20-41     DataExplorer_0.8.2  faux_1.0.0          dplyr_1.0.2         magrittr_1.5       
[17] parsnip_0.1.6       ggplot2_3.3.2      

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.5           lubridate_1.7.9.2    class_7.3-17         digest_0.6.27        ipred_0.9-9          R6_2.5.0             plyr_1.8.6           stats4_4.0.3        
 [9] evaluate_0.14        pillar_1.4.6         rlang_0.4.8          rstudioapi_0.13      data.table_1.14.0    Matrix_1.2-18        rmarkdown_2.5        splines_4.0.3       
[17] gower_0.2.2          stringr_1.4.0        htmlwidgets_1.5.2    igraph_1.2.6         munsell_0.5.0        compiler_4.0.3       xfun_0.19            pkgconfig_2.0.3     
[25] htmltools_0.5.0      nnet_7.3-14          tidyselect_1.1.0     gridExtra_2.3        prodlim_2019.11.13   codetools_0.2-16     crayon_1.3.4         withr_2.3.0         
[33] MASS_7.3-53          recipes_0.1.15       ModelMetrics_1.2.2.2 grid_4.0.3           nlme_3.1-149         gtable_0.3.0         lifecycle_0.2.0      pROC_1.16.2         
[41] scales_1.1.1         stringi_1.5.3        reshape2_1.4.4       timeDate_3043.102    ellipsis_0.3.1       generics_0.1.0       vctrs_0.3.4          lava_1.6.8.1        
[49] tools_4.0.3          glue_1.4.2           purrr_0.3.4          networkD3_0.4        survival_3.2-7       colorspace_2.0-0     knitr_1.30          
df <- read.csv("data/shield_gjames_21-06-10.csv")
grouping_var <- "behaviour_unmasked"
# feature_list <- colnames(df[, !(names(df) %in% c(grouping_var, "id"))])
feature_list <- c('intention_indoor_meeting', 'norms_people_present_indoors',
       'sdt_motivation_extrinsic_2', 'sdt_motivation_identified_4', 'norms_family_friends', 'norms_risk_groups', 'norms_officials',
       'norms_people_present_indoors')
if (grouping_var == "behaviour_unmasked") {
  # df <- df %>% mutate(tmp = if_else(!!as.symbol(grouping_var) != 5, 'bad', 'good'))
  df <- df %>% mutate(tmp = if_else(!!as.symbol(grouping_var) != 5, 0, 1))

  names(df)[names(df) == 'tmp'] <- paste0(grouping_var, "_bool")
}
    
df[, paste0(grouping_var, "_bool")] <- as.factor(df[, paste0(grouping_var, "_bool")])
# df %<>%
#        mutate_each_(funs(factor(.)), colnames(df))
# str(df)

ordinal_vars_mydata <- ordering_lookup %>% 
  dplyr::filter(varname %in% names(df)) %>% 
  dplyr::filter(ordering == "ordered")
  
df <- df %>% 
  # Ordered variables as ordinal factors
  dplyr::mutate(across(.cols = ordinal_vars_mydata$varname, 
                        ~factor(., ordered = TRUE))) %>% 
  # Everything else as unordered factors
  dplyr::mutate(across(.cols = -ordinal_vars_mydata$varname, 
                        ~factor(.))) %>% 
  # Fix ordering in the intention variables
  dplyr::mutate(across(.cols = contains("intention_"), 
                        ~dplyr::recode_factor(.,
                                              "1" = "4",
                                              "2" = "1", 
                                              "3" = "2",
                                              "4" = "3",
                                              .ordered = TRUE)))

str(df)
'data.frame':   2272 obs. of  94 variables:
 $ id                               : Factor w/ 2272 levels "1","2","3","4",..: 1 2 3 4 5 6 7 8 9 10 ...
 $ demographic_gender               : Factor w/ 2 levels "1","2": 1 2 1 1 1 2 2 2 1 1 ...
 $ demographic_age                  : Ord.factor w/ 5 levels "18-29"<"30-39"<..: 4 2 1 5 5 4 1 2 5 5 ...
 $ demographic_4_areas              : Factor w/ 4 levels "1","2","3","4": 1 2 1 1 2 1 1 4 4 1 ...
 $ demographic_8_areas              : Factor w/ 8 levels "1","2","3","4",..: 2 6 2 2 7 1 2 6 6 7 ...
 $ behaviour_indoors_nonhouseholders: Ord.factor w/ 6 levels "1"<"2"<"3"<"4"<..: 5 5 3 4 5 3 5 5 4 5 ...
 $ behaviour_close_contact          : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 4 4 2 3 4 3 4 4 4 3 ...
 $ behaviour_quarantined            : Factor w/ 3 levels "1","2","3": 2 2 2 2 2 2 2 2 2 2 ...
 $ behaviour_unmasked               : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 5 5 2 2 4 3 5 3 4 5 ...
 $ mask_wearing_cloth_mask          : Factor w/ 2 levels "0","1": 1 2 1 1 1 1 2 1 1 1 ...
 $ mask_wearing_disposable_mask     : Factor w/ 2 levels "0","1": 2 2 2 1 2 1 1 2 1 1 ...
 $ mask_wearing_certified_mask      : Factor w/ 2 levels "0","1": 1 1 1 1 1 2 1 1 2 1 ...
 $ mask_wearing_ffp2                : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 2 ...
 $ mask_wearing_vizire              : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ mask_wearing_none                : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ mask_wearing_other               : Factor w/ 2 levels "0","1": 1 1 1 2 1 1 1 1 1 1 ...
 $ mask_wearing_reuse               : Factor w/ 5 levels "1","2","3","4",..: 2 4 2 5 3 2 5 4 2 4 ...
 $ intention_store                  : Ord.factor w/ 4 levels "4"<"1"<"2"<"3": 1 1 1 1 1 1 1 3 1 1 ...
 $ intention_public_transport       : Ord.factor w/ 4 levels "4"<"1"<"2"<"3": 4 1 1 1 1 1 1 4 1 1 ...
 $ intention_indoor_meeting         : Ord.factor w/ 4 levels "4"<"1"<"2"<"3": 1 3 3 2 2 3 3 3 2 1 ...
 $ intention_restaurant             : Ord.factor w/ 4 levels "4"<"1"<"2"<"3": 2 2 2 2 1 1 2 3 1 2 ...
 $ intention_pa                     : Ord.factor w/ 4 levels "4"<"1"<"2"<"3": 2 2 4 4 3 2 4 3 2 4 ...
 $ automaticity_carry_mask          : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 3 5 6 7 6 7 1 5 6 ...
 $ automaticity_put_on_mask         : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 4 6 6 6 7 7 7 1 6 6 ...
 $ post_covid_maskwearing_if_reccd  : Factor w/ 4 levels "1","2","3","4": 3 4 4 3 1 1 4 4 1 1 ...
 $ inst_attitude_protects_self      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 6 4 4 4 6 7 4 4 6 ...
 $ inst_attitude_protects_others    : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 7 7 6 7 6 7 4 6 6 ...
 $ inst_attitude_sense_of_community : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 4 4 4 6 7 4 7 1 5 6 ...
 $ inst_attitude_enough_oxygen      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 3 7 6 7 4 7 1 5 3 ...
 $ inst_attitude_no_needless_waste  : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 3 1 7 6 7 4 7 1 5 1 ...
 $ norms_family_friends             : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 7 7 6 7 7 7 1 4 7 ...
 $ norms_risk_groups                : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 5 7 4 6 7 7 7 2 7 7 ...
 $ norms_officials                  : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 7 7 6 7 7 7 7 7 7 ...
 $ norms_people_present_indoors     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 5 7 7 6 7 4 7 4 6 7 ...
 $ aff_attitude_comfortable         : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 4 5 5 3 4 6 1 5 2 ...
 $ aff_attitude_calm                : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 4 3 7 6 7 5 6 3 6 3 ...
 $ aff_attitude_safe                : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 3 4 5 5 4 5 7 5 6 5 ...
 $ aff_attitude_responsible         : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 6 7 5 7 6 7 4 7 6 ...
 $ aff_attitude_difficult_breathing : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 4 1 3 2 5 2 6 5 5 ...
 $ barriers_nothing                 : Factor w/ 2 levels "0","1": 1 1 1 1 2 1 2 1 1 1 ...
 $ barriers_money                   : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ barriers_forget_carry            : Factor w/ 2 levels "0","1": 1 2 2 2 1 1 1 1 2 1 ...
 $ barriers_forget_wear             : Factor w/ 2 levels "0","1": 1 1 1 2 1 1 1 1 2 1 ...
 $ barriers_group_pressure          : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ barriers_medical_symptoms        : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ barriers_skin                    : Factor w/ 2 levels "0","1": 1 2 1 1 1 1 1 1 1 1 ...
 $ barriers_difficult_breathing     : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 2 1 2 ...
 $ barriers_eyeglasses_fog          : Factor w/ 2 levels "0","1": 1 2 2 2 1 2 1 2 1 2 ...
 $ barriers_raspyvoice              : Factor w/ 2 levels "0","1": 2 1 1 2 1 1 1 2 1 1 ...
 $ barriers_headache                : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ barriers_drymouth                : Factor w/ 2 levels "0","1": 1 1 1 1 1 2 1 1 1 1 ...
 $ barriers_earpain                 : Factor w/ 2 levels "0","1": 1 2 1 1 1 2 1 1 1 1 ...
 $ barriers_general_uncomfy         : Factor w/ 2 levels "0","1": 2 1 1 1 1 1 1 2 1 2 ...
 $ barriers_other                   : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
 $ effective_means_handwashing      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 1 7 5 7 6 7 7 7 7 ...
 $ effective_means_masks            : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 5 5 1 5 7 6 6 1 7 7 ...
 $ effective_means_distance         : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 4 1 7 7 5 5 7 7 7 ...
 $ effective_means_ventilation      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 4 4 7 7 5 5 4 6 7 ...
 $ risk_likely_contagion            : Ord.factor w/ 8 levels "1"<"2"<"3"<"4"<..: 2 4 4 3 2 2 2 3 3 1 ...
 $ risk_contagion_absent_protection : Ord.factor w/ 8 levels "1"<"2"<"3"<"4"<..: 6 5 6 5 6 5 6 3 6 4 ...
 $ risk_severity                    : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 2 5 6 4 5 3 1 4 7 ...
 $ risk_fear_spread                 : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 4 5 7 4 6 5 7 4 3 7 ...
 $ risk_fear_contagion_self         : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 3 5 6 4 5 3 3 4 7 ...
 $ risk_fear_contagion_others       : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 7 6 6 7 6 7 7 4 7 ...
 $ risk_fear_restrictions           : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 5 3 1 3 1 4 1 7 3 4 ...
 $ sdt_needs_autonomy_1             : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 2 3 5 3 5 2 5 2 4 2 ...
 $ sdt_needs_competence_1           : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 3 4 5 4 5 4 5 4 4 3 ...
 $ sdt_needs_relatedness_1          : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 3 5 1 4 5 4 5 1 5 4 ...
 $ sdt_needs_autonomy_2             : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 2 4 2 3 5 4 5 1 4 4 ...
 $ sdt_needs_competence_2           : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 3 5 5 2 4 4 5 3 4 3 ...
 $ sdt_needs_relatedness_2          : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 3 2 4 3 5 4 5 2 5 4 ...
 $ sdt_motivation_extrinsic1        : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 1 1 2 1 2 2 1 4 1 ...
 $ sdt_motivation_amotivation_1     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 1 1 1 2 1 1 1 5 2 1 ...
 $ sdt_motivation_identified_1      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 7 7 5 6 7 6 7 4 7 7 ...
 $ sdt_motivation_introjected_1     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 5 5 1 3 6 3 5 1 6 6 ...
 $ sdt_motivation_extrinsic_2       : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 4 1 2 2 4 1 5 2 1 ...
 $ sdt_motivation_introjected_2     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 5 1 5 6 5 7 1 6 4 ...
 $ sdt_motivation_amotivation_2     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 1 1 1 1 1 2 1 5 1 1 ...
 $ sdt_motivation_extrinsic_3       : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 1 2 1 4 1 5 1 6 2 1 ...
 $ sdt_motivation_identified_2      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 3 7 3 6 7 5 7 1 6 6 ...
 $ sdt_motivation_identified_3      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 6 7 2 6 7 5 7 1 7 6 ...
 $ sdt_motivation_identified_4      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 4 7 4 5 7 5 7 1 6 6 ...
 $ sdt_motivation_amotivation_3     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 1 1 2 1 1 1 6 1 1 ...
 $ sdt_motivation_introjected_3     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 7 3 5 6 5 5 4 6 6 ...
 $ attention_check                  : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 1 1 2 1 1 1 1 1 1 ...
 $ vaccination_status_intention_self: Ord.factor w/ 5 levels "4"<"1"<"2"<"3"<..: 1 2 3 1 1 1 3 4 1 2 ...
 $ vaccination_status_closeones     : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 1 2 1 2 4 2 3 2 4 4 ...
 $ covid_tested                     : Factor w/ 4 levels "1","2","3","4": 1 3 2 2 3 1 2 2 2 2 ...
 $ had_covid                        : Ord.factor w/ 5 levels "1"<"2"<"3"<"4"<..: 1 2 5 2 1 1 4 1 2 1 ...
 $ demographic_risk_group           : Factor w/ 3 levels "1","2","3": 2 2 2 1 2 2 2 2 2 3 ...
 $ needprotection_before_shots      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 1 1 1 2 1 1 1 4 1 1 ...
 $ needprotection_after_1_shot      : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 2 2 1 2 1 2 1 4 1 1 ...
 $ needprotection_after_2_shots     : Ord.factor w/ 7 levels "1"<"2"<"3"<"4"<..: 3 5 7 2 3 3 3 4 1 1 ...
 $ behaviour_unmasked_bool          : Factor w/ 2 levels "0","1": 2 2 1 1 1 1 2 1 1 2 ...
# Exploratory data analysis
plot_intro(df)

plot_bar(df)
1 columns ignored with more than 50 categories.
id: 2272 categories

plot_correlation(df)
1 features with more than 20 categories ignored!
id: 2272 categories

head(df[, c(paste0(grouping_var, "_bool"), grouping_var)])
x <- df %>%
  select(-behaviour_unmasked_bool, -behaviour_unmasked, -id) %>%
  as.data.frame()

y <- df$behaviour_unmasked_bool
set.seed(2021)
inTrain <- createDataPartition(y, p = .80, list = FALSE)[,1]

x_train <- x[ inTrain, ]
x_test  <- x[-inTrain, ]

y_train <- y[ inTrain]
y_test  <- y[-inTrain]

colnames(x_train)
 [1] "demographic_gender"                "demographic_age"                   "demographic_4_areas"               "demographic_8_areas"              
 [5] "behaviour_indoors_nonhouseholders" "behaviour_close_contact"           "behaviour_quarantined"             "mask_wearing_cloth_mask"          
 [9] "mask_wearing_disposable_mask"      "mask_wearing_certified_mask"       "mask_wearing_ffp2"                 "mask_wearing_vizire"              
[13] "mask_wearing_none"                 "mask_wearing_other"                "mask_wearing_reuse"                "intention_store"                  
[17] "intention_public_transport"        "intention_indoor_meeting"          "intention_restaurant"              "intention_pa"                     
[21] "automaticity_carry_mask"           "automaticity_put_on_mask"          "post_covid_maskwearing_if_reccd"   "inst_attitude_protects_self"      
[25] "inst_attitude_protects_others"     "inst_attitude_sense_of_community"  "inst_attitude_enough_oxygen"       "inst_attitude_no_needless_waste"  
[29] "norms_family_friends"              "norms_risk_groups"                 "norms_officials"                   "norms_people_present_indoors"     
[33] "aff_attitude_comfortable"          "aff_attitude_calm"                 "aff_attitude_safe"                 "aff_attitude_responsible"         
[37] "aff_attitude_difficult_breathing"  "barriers_nothing"                  "barriers_money"                    "barriers_forget_carry"            
[41] "barriers_forget_wear"              "barriers_group_pressure"           "barriers_medical_symptoms"         "barriers_skin"                    
[45] "barriers_difficult_breathing"      "barriers_eyeglasses_fog"           "barriers_raspyvoice"               "barriers_headache"                
[49] "barriers_drymouth"                 "barriers_earpain"                  "barriers_general_uncomfy"          "barriers_other"                   
[53] "effective_means_handwashing"       "effective_means_masks"             "effective_means_distance"          "effective_means_ventilation"      
[57] "risk_likely_contagion"             "risk_contagion_absent_protection"  "risk_severity"                     "risk_fear_spread"                 
[61] "risk_fear_contagion_self"          "risk_fear_contagion_others"        "risk_fear_restrictions"            "sdt_needs_autonomy_1"             
[65] "sdt_needs_competence_1"            "sdt_needs_relatedness_1"           "sdt_needs_autonomy_2"              "sdt_needs_competence_2"           
[69] "sdt_needs_relatedness_2"           "sdt_motivation_extrinsic1"         "sdt_motivation_amotivation_1"      "sdt_motivation_identified_1"      
[73] "sdt_motivation_introjected_1"      "sdt_motivation_extrinsic_2"        "sdt_motivation_introjected_2"      "sdt_motivation_amotivation_2"     
[77] "sdt_motivation_extrinsic_3"        "sdt_motivation_identified_2"       "sdt_motivation_identified_3"       "sdt_motivation_identified_4"      
[81] "sdt_motivation_amotivation_3"      "sdt_motivation_introjected_3"      "attention_check"                   "vaccination_status_intention_self"
[85] "vaccination_status_closeones"      "covid_tested"                      "had_covid"                         "demographic_risk_group"           
[89] "needprotection_before_shots"       "needprotection_after_1_shot"       "needprotection_after_2_shots"     

Running an ordinal variant of a decision tree (rpartScore) using the top features found, with a grid search CV

# # Define the control using a random forest selection function
# control <- rfeControl(functions = rfFuncs, # random forest
#                       method = "repeatedcv", # or just cv
#                       repeats = 10, # number of repeats
#                       number = 10) # the number of folds
tictoc::tic()
cl <- makePSOCKcluster(10)
registerDoParallel(cl)

set.seed(2021)

# Specify 10 fold cross-validation
ctrl_cv <- trainControl(method = "repeatedcv",
                        search="grid",
                        number = 10,
                        repeats=10,
                        timingSamps = 5,
                        # seeds = c(1:101)
                        )
# Predict income using decision tree
dec_mod <- train(x=x_train,
                 y=y_train,
                    method = "rpartScore",  
                    trControl = ctrl_cv,
                    tuneGrid = expand.grid(
                      cp = seq(0,1,0.1),
                      split = c("abs", "quad"),
                      prune = c("mc", "mr")
                      )

                 )

stopCluster(cl)
tictoc::toc()
1357.946 sec elapsed
registerDoSEQ()
varimp_data <- varImp(dec_mod)
varimp_data
rpartScore variable importance

  only 20 most important variables shown (out of 91)
dec_mod$results
# Post prediction
postResample(predict(dec_mod, x_test), y_test)
 Accuracy     Kappa 
0.7026432 0.3190151 
prediction_tibble <- tibble("target"=y_test,
       "prediction"=predict(dec_mod, x_test))
prediction_table <- table(prediction_tibble)
cfm <- as_tibble(prediction_table)
plot_confusion_matrix(cfm, 
                      target_col = "target", 
                      prediction_col = "prediction",
                      counts_col = "n")
'rsvg' is missing. Will not plot arrows and zero-shading.

fancyRpartPlot(dec_mod$finalModel)
Unrecognized rpart object: treating as a numeric response model

pred_df <- data.frame(target=as.numeric(y_test),
           prediction=as.numeric(predict(dec_mod, x_test)),
           row.names = rownames(x_test))

pred_df$correct_or_not <- pred_df$target + pred_df$prediction

zero_ids <- rownames(pred_df[pred_df[, "correct_or_not"] == 2,])
one_ids <- rownames(pred_df[pred_df[, "correct_or_not"] == 4,])

length(zero_ids)
[1] 249
length(one_ids)
[1] 70
df[zero_ids, ]
df[one_ids, ]
top_features <- rownames(head(varimp_data$importance, 3))
# top_features <- c("behaviour_indoors_nonhouseholders", "behaviour_close_contact", "intention_indoor_meeting")
# df$demographic_gender <- factor(df$demographic_gender)
# df <- data.frame(apply(df, 2, factor))
# df %<>%
#        mutate_each_(funs(factor(.)),top_features)
# # str(df)
x <- df[top_features]

y <- factor(df$behaviour_unmasked_bool)
set.seed(2021)
inTrain <- createDataPartition(y, p = .80, list = FALSE)[,1]

x_train <- x[ inTrain, ]
x_test  <- x[-inTrain, ]

y_train <- y[ inTrain]
y_test  <- y[-inTrain]

colnames(x_train)
[1] "behaviour_indoors_nonhouseholders" "intention_store"                   "covid_tested"                     
cl <- makePSOCKcluster(10)
registerDoParallel(cl)

set.seed(2021)

# Specify 10 fold cross-validation
ctrl_cv <- trainControl(method = "repeatedcv",
                        search="grid",
                        number = 10,
                        repeats=10,
                        timingSamps = 5,
                        # seeds = c(1:101)
                        )
# Predict income using decision tree
dec_mod <- train(x=x_train,
                 y=y_train,
                    method = "rpartScore",  
                    trControl = ctrl_cv,
                    tuneGrid = expand.grid(
                      cp = seq(0,1,0.1),
                      split = c("abs", "quad"),
                      prune = c("mc", "mr")
                      )

                 )

stopCluster(cl)
registerDoSEQ()
# Post prediction
postResample(predict(dec_mod, x_test), y_test)
 Accuracy     Kappa 
0.7048458 0.3186542 
prediction_tibble <- tibble("target"=y_test,
       "prediction"=predict(dec_mod, x_test))
prediction_table <- table(prediction_tibble)
cfm <- as_tibble(prediction_table)
plot_confusion_matrix(cfm, 
                      target_col = "target", 
                      prediction_col = "prediction",
                      counts_col = "n")
'rsvg' is missing. Will not plot arrows and zero-shading.

NA
NA
fancyRpartPlot(dec_mod$finalModel)
Unrecognized rpart object: treating as a numeric response model

varImp(dec_mod)
rpartScore variable importance
ggplot(data=df, aes(x=id, y=intention_store, color=demographic_gender)) + geom_point()

ggplot(data=df, aes(x=id, y=behaviour_indoors_nonhouseholders, color=demographic_gender)) + geom_point()

dec_mod
CART or Ordinal Responses 

1818 samples
   3 predictor
   2 classes: '0', '1' 

No pre-processing
Resampling: Cross-Validated (10 fold, repeated 10 times) 
Summary of sample sizes: 1637, 1637, 1637, 1636, 1635, 1637, ... 
Resampling results across tuning parameters:

  cp   split  prune  Accuracy   Kappa    
  0.0  abs    mc     0.7085242  0.3305165
  0.0  abs    mr     0.7085242  0.3305165
  0.0  quad   mc     0.7111667  0.3354733
  0.0  quad   mr     0.7111667  0.3354733
  0.1  abs    mc     0.7095697  0.3349478
  0.1  abs    mr     0.7095697  0.3349478
  0.1  quad   mc     0.7095697  0.3349478
  0.1  quad   mr     0.7095697  0.3349478
  0.2  abs    mc     0.7095697  0.3349478
  0.2  abs    mr     0.7095697  0.3349478
  0.2  quad   mc     0.7095697  0.3349478
  0.2  quad   mr     0.7095697  0.3349478
  0.3  abs    mc     0.6122135  0.0000000
  0.3  abs    mr     0.6122135  0.0000000
  0.3  quad   mc     0.6122135  0.0000000
  0.3  quad   mr     0.6122135  0.0000000
  0.4  abs    mc     0.6122135  0.0000000
  0.4  abs    mr     0.6122135  0.0000000
  0.4  quad   mc     0.6122135  0.0000000
  0.4  quad   mr     0.6122135  0.0000000
  0.5  abs    mc     0.6122135  0.0000000
  0.5  abs    mr     0.6122135  0.0000000
  0.5  quad   mc     0.6122135  0.0000000
  0.5  quad   mr     0.6122135  0.0000000
  0.6  abs    mc     0.6122135  0.0000000
  0.6  abs    mr     0.6122135  0.0000000
  0.6  quad   mc     0.6122135  0.0000000
  0.6  quad   mr     0.6122135  0.0000000
  0.7  abs    mc     0.6122135  0.0000000
  0.7  abs    mr     0.6122135  0.0000000
  0.7  quad   mc     0.6122135  0.0000000
  0.7  quad   mr     0.6122135  0.0000000
  0.8  abs    mc     0.6122135  0.0000000
  0.8  abs    mr     0.6122135  0.0000000
  0.8  quad   mc     0.6122135  0.0000000
  0.8  quad   mr     0.6122135  0.0000000
  0.9  abs    mc     0.6122135  0.0000000
  0.9  abs    mr     0.6122135  0.0000000
  0.9  quad   mc     0.6122135  0.0000000
  0.9  quad   mr     0.6122135  0.0000000
  1.0  abs    mc     0.6122135  0.0000000
  1.0  abs    mr     0.6122135  0.0000000
  1.0  quad   mc     0.6122135  0.0000000
  1.0  quad   mr     0.6122135  0.0000000

Accuracy was used to select the optimal model using the largest value.
The final values used for the model were cp = 0, split = quad and prune = mc.
dec_mod$bestTune
dec_mod$finalModel
n= 1818 

node), split, n, deviance, yval
      * denotes terminal node

 1) root 1818 705 1  
   2) behaviour_indoors_nonhouseholders=1,2,3,4,5 1421 418 1 *
   3) behaviour_indoors_nonhouseholders=6 397 110 2  
     6) covid_tested=1 79  32 2 *
     7) covid_tested=2,3,4 318  78 2  
      14) intention_store=1,2,3 27  13 2  
        28) intention_store=4,1,2 17   7 1 *
        29) intention_store=3 10   3 2 *
      15) intention_store=4 291  65 2 *
LS0tCnRpdGxlOiAiQ29yb25hIHByZXBwaW5nIHVzaW5nIEZpbm5pc2ggZGF0YSBEZWNpc2lvbiBUcmVlcyIKYXV0aG9yOiAiSmFtZXMgVHdvc2UiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KCk1haW4gcXVlc3Rpb246IGF0IHRoaXMgcG9pbnQgd2UncmUgaW50ZXJlc3RlZCBpbiBvbmUgc2luZ2xlIGNsYXNzaWZpY2F0aW9uLCBpLmUuIHdoYXQgcHJlZGljdHMgd2hldGhlciBwZW9wbGUgZG8gbWFza2xlc3MgY29udGFjdHMgd2l0aCBub24taG91c2Vob2xkZXJzCgpbUmVzZWFyY2ggRG9jdW1lbnRdKGh0dHBzOi8vZG9jcy5nb29nbGUuY29tL2RvY3VtZW50L2QvMWlMY2lIY3ZWdmY4UXdGUzd3aXlOQmV2cEQxQjl5RFJxTWxNNF9vQ2NWY0EvZWRpdD91c3A9c2hhcmluZykKCltRdWVzdGlvbnMgY29kZWJvb2tdKGh0dHBzOi8vZG9jcy5nb29nbGUuY29tL2RvY3VtZW50L2QvMVlaVkNQMVVOeG5OTEFLMmtZRGZBOVk5OGxlVFpZdXJaRC1kOGlCeWhkaTAvZWRpdD91c3A9c2hhcmluZykKCltNZXRob2Qgb2YgZGVsaXZlcnldKGh0dHBzOi8vZG9jcy5nb29nbGUuY29tL2RvY3VtZW50L2QvMUcxSlQ5SlVKclRLM2FhWFh1UmF3WUFDSmFHTnhVN21jWEw5aS1kOGVLWFkvZWRpdCkKCmBgYHtyLCBlY2hvPUZBTFNFLCBtZXNzYWdlPUZBTFNFfQpsaWJyYXJ5KGdncGxvdDIpCmxpYnJhcnkocGFyc25pcCkKbGlicmFyeShtYWdyaXR0cikKbGlicmFyeShkcGx5cikKbGlicmFyeShmYXV4KQpsaWJyYXJ5KERhdGFFeHBsb3JlcikKbGlicmFyeShjYXJldCkKbGlicmFyeShyYW5kb21Gb3Jlc3QpCmxpYnJhcnkodGlkeXIpCmxpYnJhcnkoY3ZtcykKbGlicmFyeShkb1BhcmFsbGVsKQpsaWJyYXJ5KHJhdHRsZSkKbGlicmFyeShycGFydCkKc291cmNlKCJjb3JvbmFwcmVwcGVyc19leHRyYXMuUiIpCmBgYAoKYGBge3J9CnNlc3Npb25JbmZvKCkKYGBgCgoKYGBge3J9CmRmIDwtIHJlYWQuY3N2KCJkYXRhL3NoaWVsZF9namFtZXNfMjEtMDYtMTAuY3N2IikKYGBgCgpgYGB7cn0KZ3JvdXBpbmdfdmFyIDwtICJiZWhhdmlvdXJfdW5tYXNrZWQiCiMgZmVhdHVyZV9saXN0IDwtIGNvbG5hbWVzKGRmWywgIShuYW1lcyhkZikgJWluJSBjKGdyb3VwaW5nX3ZhciwgImlkIikpXSkKZmVhdHVyZV9saXN0IDwtIGMoJ2ludGVudGlvbl9pbmRvb3JfbWVldGluZycsICdub3Jtc19wZW9wbGVfcHJlc2VudF9pbmRvb3JzJywKICAgICAgICdzZHRfbW90aXZhdGlvbl9leHRyaW5zaWNfMicsICdzZHRfbW90aXZhdGlvbl9pZGVudGlmaWVkXzQnLCAnbm9ybXNfZmFtaWx5X2ZyaWVuZHMnLCAnbm9ybXNfcmlza19ncm91cHMnLCAnbm9ybXNfb2ZmaWNpYWxzJywKICAgICAgICdub3Jtc19wZW9wbGVfcHJlc2VudF9pbmRvb3JzJykKYGBgCgpgYGB7cn0KaWYgKGdyb3VwaW5nX3ZhciA9PSAiYmVoYXZpb3VyX3VubWFza2VkIikgewogICMgZGYgPC0gZGYgJT4lIG11dGF0ZSh0bXAgPSBpZl9lbHNlKCEhYXMuc3ltYm9sKGdyb3VwaW5nX3ZhcikgIT0gNSwgJ2JhZCcsICdnb29kJykpCiAgZGYgPC0gZGYgJT4lIG11dGF0ZSh0bXAgPSBpZl9lbHNlKCEhYXMuc3ltYm9sKGdyb3VwaW5nX3ZhcikgIT0gNSwgMCwgMSkpCgogIG5hbWVzKGRmKVtuYW1lcyhkZikgPT0gJ3RtcCddIDwtIHBhc3RlMChncm91cGluZ192YXIsICJfYm9vbCIpCn0KICAgIApgYGAKCmBgYHtyfQpkZlssIHBhc3RlMChncm91cGluZ192YXIsICJfYm9vbCIpXSA8LSBhcy5mYWN0b3IoZGZbLCBwYXN0ZTAoZ3JvdXBpbmdfdmFyLCAiX2Jvb2wiKV0pCmBgYAoKYGBge3J9CiMgZGYgJTw+JQojICAgICAgICBtdXRhdGVfZWFjaF8oZnVucyhmYWN0b3IoLikpLCBjb2xuYW1lcyhkZikpCiMgc3RyKGRmKQoKb3JkaW5hbF92YXJzX215ZGF0YSA8LSBvcmRlcmluZ19sb29rdXAgJT4lIAogIGRwbHlyOjpmaWx0ZXIodmFybmFtZSAlaW4lIG5hbWVzKGRmKSkgJT4lIAogIGRwbHlyOjpmaWx0ZXIob3JkZXJpbmcgPT0gIm9yZGVyZWQiKQogIApkZiA8LSBkZiAlPiUgCiAgIyBPcmRlcmVkIHZhcmlhYmxlcyBhcyBvcmRpbmFsIGZhY3RvcnMKICBkcGx5cjo6bXV0YXRlKGFjcm9zcyguY29scyA9IG9yZGluYWxfdmFyc19teWRhdGEkdmFybmFtZSwgCiAgICAgICAgICAgICAgICAgICAgICAgIH5mYWN0b3IoLiwgb3JkZXJlZCA9IFRSVUUpKSkgJT4lIAogICMgRXZlcnl0aGluZyBlbHNlIGFzIHVub3JkZXJlZCBmYWN0b3JzCiAgZHBseXI6Om11dGF0ZShhY3Jvc3MoLmNvbHMgPSAtb3JkaW5hbF92YXJzX215ZGF0YSR2YXJuYW1lLCAKICAgICAgICAgICAgICAgICAgICAgICAgfmZhY3RvciguKSkpICU+JSAKICAjIEZpeCBvcmRlcmluZyBpbiB0aGUgaW50ZW50aW9uIHZhcmlhYmxlcwogIGRwbHlyOjptdXRhdGUoYWNyb3NzKC5jb2xzID0gY29udGFpbnMoImludGVudGlvbl8iKSwgCiAgICAgICAgICAgICAgICAgICAgICAgIH5kcGx5cjo6cmVjb2RlX2ZhY3RvciguLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIjEiID0gIjQiLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIjIiID0gIjEiLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICIzIiA9ICIyIiwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICI0IiA9ICIzIiwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIC5vcmRlcmVkID0gVFJVRSkpKQoKc3RyKGRmKQoKYGBgCgpgYGB7ciwgZmlnLmhlaWdodD0xNSwgZmlnLndpZHRoPTE1fQojIEV4cGxvcmF0b3J5IGRhdGEgYW5hbHlzaXMKcGxvdF9pbnRybyhkZikKcGxvdF9iYXIoZGYpCnBsb3RfY29ycmVsYXRpb24oZGYpCmBgYAoKCmBgYHtyfQpoZWFkKGRmWywgYyhwYXN0ZTAoZ3JvdXBpbmdfdmFyLCAiX2Jvb2wiKSwgZ3JvdXBpbmdfdmFyKV0pCmBgYAoKYGBge3J9CnggPC0gZGYgJT4lCiAgc2VsZWN0KC1iZWhhdmlvdXJfdW5tYXNrZWRfYm9vbCwgLWJlaGF2aW91cl91bm1hc2tlZCwgLWlkKSAlPiUKICBhcy5kYXRhLmZyYW1lKCkKCnkgPC0gZGYkYmVoYXZpb3VyX3VubWFza2VkX2Jvb2wKYGBgCgoKYGBge3J9CnNldC5zZWVkKDIwMjEpCmluVHJhaW4gPC0gY3JlYXRlRGF0YVBhcnRpdGlvbih5LCBwID0gLjgwLCBsaXN0ID0gRkFMU0UpWywxXQoKeF90cmFpbiA8LSB4WyBpblRyYWluLCBdCnhfdGVzdCAgPC0geFstaW5UcmFpbiwgXQoKeV90cmFpbiA8LSB5WyBpblRyYWluXQp5X3Rlc3QgIDwtIHlbLWluVHJhaW5dCgpjb2xuYW1lcyh4X3RyYWluKQpgYGAKCgojIFJ1bm5pbmcgYW4gb3JkaW5hbCB2YXJpYW50IG9mIGEgZGVjaXNpb24gdHJlZSAocnBhcnRTY29yZSkgdXNpbmcgdGhlIHRvcCBmZWF0dXJlcyBmb3VuZCwgd2l0aCBhIGdyaWQgc2VhcmNoIENWCgpgYGB7cn0KIyAjIERlZmluZSB0aGUgY29udHJvbCB1c2luZyBhIHJhbmRvbSBmb3Jlc3Qgc2VsZWN0aW9uIGZ1bmN0aW9uCiMgY29udHJvbCA8LSByZmVDb250cm9sKGZ1bmN0aW9ucyA9IHJmRnVuY3MsICMgcmFuZG9tIGZvcmVzdAojICAgICAgICAgICAgICAgICAgICAgICBtZXRob2QgPSAicmVwZWF0ZWRjdiIsICMgb3IganVzdCBjdgojICAgICAgICAgICAgICAgICAgICAgICByZXBlYXRzID0gMTAsICMgbnVtYmVyIG9mIHJlcGVhdHMKIyAgICAgICAgICAgICAgICAgICAgICAgbnVtYmVyID0gMTApICMgdGhlIG51bWJlciBvZiBmb2xkcwpgYGAKCgpgYGB7cn0KdGljdG9jOjp0aWMoKQpjbCA8LSBtYWtlUFNPQ0tjbHVzdGVyKDEwKQpyZWdpc3RlckRvUGFyYWxsZWwoY2wpCgpzZXQuc2VlZCgyMDIxKQoKIyBTcGVjaWZ5IDEwIGZvbGQgY3Jvc3MtdmFsaWRhdGlvbgpjdHJsX2N2IDwtIHRyYWluQ29udHJvbChtZXRob2QgPSAicmVwZWF0ZWRjdiIsCiAgICAgICAgICAgICAgICAgICAgICAgIHNlYXJjaD0iZ3JpZCIsCiAgICAgICAgICAgICAgICAgICAgICAgIG51bWJlciA9IDEwLAogICAgICAgICAgICAgICAgICAgICAgICByZXBlYXRzPTEwLAogICAgICAgICAgICAgICAgICAgICAgICB0aW1pbmdTYW1wcyA9IDUsCiAgICAgICAgICAgICAgICAgICAgICAgICMgc2VlZHMgPSBjKDE6MTAxKQogICAgICAgICAgICAgICAgICAgICAgICApCiMgUHJlZGljdCBpbmNvbWUgdXNpbmcgZGVjaXNpb24gdHJlZQpkZWNfbW9kIDwtIHRyYWluKHg9eF90cmFpbiwKICAgICAgICAgICAgICAgICB5PXlfdHJhaW4sCiAgICAgICAgICAgICAgICAgICAgbWV0aG9kID0gInJwYXJ0U2NvcmUiLCAgCiAgICAgICAgICAgICAgICAgICAgdHJDb250cm9sID0gY3RybF9jdiwKICAgICAgICAgICAgICAgICAgICB0dW5lR3JpZCA9IGV4cGFuZC5ncmlkKAogICAgICAgICAgICAgICAgICAgICAgY3AgPSBzZXEoMCwxLDAuMSksCiAgICAgICAgICAgICAgICAgICAgICBzcGxpdCA9IGMoImFicyIsICJxdWFkIiksCiAgICAgICAgICAgICAgICAgICAgICBwcnVuZSA9IGMoIm1jIiwgIm1yIikKICAgICAgICAgICAgICAgICAgICAgICkKCiAgICAgICAgICAgICAgICAgKQoKc3RvcENsdXN0ZXIoY2wpCnRpY3RvYzo6dG9jKCkKYGBgCgpgYGB7cn0KcmVnaXN0ZXJEb1NFUSgpCmBgYAoKCmBgYHtyfQp2YXJpbXBfZGF0YSA8LSB2YXJJbXAoZGVjX21vZCkKdmFyaW1wX2RhdGEKYGBgCgoKYGBge3J9CmRlY19tb2QkcmVzdWx0cwpgYGAKCgoKYGBge3J9CiMgUG9zdCBwcmVkaWN0aW9uCnBvc3RSZXNhbXBsZShwcmVkaWN0KGRlY19tb2QsIHhfdGVzdCksIHlfdGVzdCkKYGBgCgoKYGBge3J9CnByZWRpY3Rpb25fdGliYmxlIDwtIHRpYmJsZSgidGFyZ2V0Ij15X3Rlc3QsCiAgICAgICAicHJlZGljdGlvbiI9cHJlZGljdChkZWNfbW9kLCB4X3Rlc3QpKQpwcmVkaWN0aW9uX3RhYmxlIDwtIHRhYmxlKHByZWRpY3Rpb25fdGliYmxlKQpjZm0gPC0gYXNfdGliYmxlKHByZWRpY3Rpb25fdGFibGUpCnBsb3RfY29uZnVzaW9uX21hdHJpeChjZm0sIAogICAgICAgICAgICAgICAgICAgICAgdGFyZ2V0X2NvbCA9ICJ0YXJnZXQiLCAKICAgICAgICAgICAgICAgICAgICAgIHByZWRpY3Rpb25fY29sID0gInByZWRpY3Rpb24iLAogICAgICAgICAgICAgICAgICAgICAgY291bnRzX2NvbCA9ICJuIikKYGBgCgpgYGB7ciwgZmlnLmhlaWdodD0xMCwgZmlnLndpZHRoPTE1fQpmYW5jeVJwYXJ0UGxvdChkZWNfbW9kJGZpbmFsTW9kZWwpCmBgYAoKCmBgYHtyfQpwcmVkX2RmIDwtIGRhdGEuZnJhbWUodGFyZ2V0PWFzLm51bWVyaWMoeV90ZXN0KSwKICAgICAgICAgICBwcmVkaWN0aW9uPWFzLm51bWVyaWMocHJlZGljdChkZWNfbW9kLCB4X3Rlc3QpKSwKICAgICAgICAgICByb3cubmFtZXMgPSByb3duYW1lcyh4X3Rlc3QpKQoKcHJlZF9kZiRjb3JyZWN0X29yX25vdCA8LSBwcmVkX2RmJHRhcmdldCArIHByZWRfZGYkcHJlZGljdGlvbgoKemVyb19pZHMgPC0gcm93bmFtZXMocHJlZF9kZltwcmVkX2RmWywgImNvcnJlY3Rfb3Jfbm90Il0gPT0gMixdKQpvbmVfaWRzIDwtIHJvd25hbWVzKHByZWRfZGZbcHJlZF9kZlssICJjb3JyZWN0X29yX25vdCJdID09IDQsXSkKCmxlbmd0aCh6ZXJvX2lkcykKbGVuZ3RoKG9uZV9pZHMpCmBgYAoKYGBge3J9CmRmW3plcm9faWRzLCBdCmRmW29uZV9pZHMsIF0KYGBgCgpgYGB7cn0KdG9wX2ZlYXR1cmVzIDwtIHJvd25hbWVzKGhlYWQodmFyaW1wX2RhdGEkaW1wb3J0YW5jZSwgMykpCiMgdG9wX2ZlYXR1cmVzIDwtIGMoImJlaGF2aW91cl9pbmRvb3JzX25vbmhvdXNlaG9sZGVycyIsICJiZWhhdmlvdXJfY2xvc2VfY29udGFjdCIsICJpbnRlbnRpb25faW5kb29yX21lZXRpbmciKQpgYGAKCmBgYHtyfQojIGRmJGRlbW9ncmFwaGljX2dlbmRlciA8LSBmYWN0b3IoZGYkZGVtb2dyYXBoaWNfZ2VuZGVyKQojIGRmIDwtIGRhdGEuZnJhbWUoYXBwbHkoZGYsIDIsIGZhY3RvcikpCmBgYAoKYGBge3J9CiMgZGYgJTw+JQojICAgICAgICBtdXRhdGVfZWFjaF8oZnVucyhmYWN0b3IoLikpLHRvcF9mZWF0dXJlcykKIyAjIHN0cihkZikKYGBgCgoKYGBge3J9CnggPC0gZGZbdG9wX2ZlYXR1cmVzXQoKeSA8LSBmYWN0b3IoZGYkYmVoYXZpb3VyX3VubWFza2VkX2Jvb2wpCgpgYGAKCmBgYHtyfQpzZXQuc2VlZCgyMDIxKQppblRyYWluIDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24oeSwgcCA9IC44MCwgbGlzdCA9IEZBTFNFKVssMV0KCnhfdHJhaW4gPC0geFsgaW5UcmFpbiwgXQp4X3Rlc3QgIDwtIHhbLWluVHJhaW4sIF0KCnlfdHJhaW4gPC0geVsgaW5UcmFpbl0KeV90ZXN0ICA8LSB5Wy1pblRyYWluXQoKY29sbmFtZXMoeF90cmFpbikKYGBgCgpgYGB7cn0KY2wgPC0gbWFrZVBTT0NLY2x1c3RlcigxMCkKcmVnaXN0ZXJEb1BhcmFsbGVsKGNsKQoKc2V0LnNlZWQoMjAyMSkKCiMgU3BlY2lmeSAxMCBmb2xkIGNyb3NzLXZhbGlkYXRpb24KY3RybF9jdiA8LSB0cmFpbkNvbnRyb2wobWV0aG9kID0gInJlcGVhdGVkY3YiLAogICAgICAgICAgICAgICAgICAgICAgICBzZWFyY2g9ImdyaWQiLAogICAgICAgICAgICAgICAgICAgICAgICBudW1iZXIgPSAxMCwKICAgICAgICAgICAgICAgICAgICAgICAgcmVwZWF0cz0xMCwKICAgICAgICAgICAgICAgICAgICAgICAgdGltaW5nU2FtcHMgPSA1LAogICAgICAgICAgICAgICAgICAgICAgICAjIHNlZWRzID0gYygxOjEwMSkKICAgICAgICAgICAgICAgICAgICAgICAgKQojIFByZWRpY3QgaW5jb21lIHVzaW5nIGRlY2lzaW9uIHRyZWUKZGVjX21vZCA8LSB0cmFpbih4PXhfdHJhaW4sCiAgICAgICAgICAgICAgICAgeT15X3RyYWluLAogICAgICAgICAgICAgICAgICAgIG1ldGhvZCA9ICJycGFydFNjb3JlIiwgIAogICAgICAgICAgICAgICAgICAgIHRyQ29udHJvbCA9IGN0cmxfY3YsCiAgICAgICAgICAgICAgICAgICAgdHVuZUdyaWQgPSBleHBhbmQuZ3JpZCgKICAgICAgICAgICAgICAgICAgICAgIGNwID0gc2VxKDAsMSwwLjEpLAogICAgICAgICAgICAgICAgICAgICAgc3BsaXQgPSBjKCJhYnMiLCAicXVhZCIpLAogICAgICAgICAgICAgICAgICAgICAgcHJ1bmUgPSBjKCJtYyIsICJtciIpCiAgICAgICAgICAgICAgICAgICAgICApCgogICAgICAgICAgICAgICAgICkKCnN0b3BDbHVzdGVyKGNsKQpgYGAKCmBgYHtyfQpyZWdpc3RlckRvU0VRKCkKYGBgCgpgYGB7cn0KIyBQb3N0IHByZWRpY3Rpb24KcG9zdFJlc2FtcGxlKHByZWRpY3QoZGVjX21vZCwgeF90ZXN0KSwgeV90ZXN0KQpgYGAKCmBgYHtyfQpwcmVkaWN0aW9uX3RpYmJsZSA8LSB0aWJibGUoInRhcmdldCI9eV90ZXN0LAogICAgICAgInByZWRpY3Rpb24iPXByZWRpY3QoZGVjX21vZCwgeF90ZXN0KSkKcHJlZGljdGlvbl90YWJsZSA8LSB0YWJsZShwcmVkaWN0aW9uX3RpYmJsZSkKY2ZtIDwtIGFzX3RpYmJsZShwcmVkaWN0aW9uX3RhYmxlKQoKYGBgCgoKYGBge3J9CnBsb3RfY29uZnVzaW9uX21hdHJpeChjZm0sIAogICAgICAgICAgICAgICAgICAgICAgdGFyZ2V0X2NvbCA9ICJ0YXJnZXQiLCAKICAgICAgICAgICAgICAgICAgICAgIHByZWRpY3Rpb25fY29sID0gInByZWRpY3Rpb24iLAogICAgICAgICAgICAgICAgICAgICAgY291bnRzX2NvbCA9ICJuIikKICAgICAgICAgICAgICAgICAgICAgIAogICAgICAgICAgICAgICAgICAgICAgCmBgYAoKYGBge3IsIGZpZy5oZWlnaHQ9MTAsIGZpZy53aWR0aD0xNX0KZmFuY3lScGFydFBsb3QoZGVjX21vZCRmaW5hbE1vZGVsKQpgYGAKCgpgYGB7cn0KdmFySW1wKGRlY19tb2QpCmBgYAoKCmBgYHtyfQpnZ3Bsb3QoZGF0YT1kZiwgYWVzKHg9aWQsIHk9aW50ZW50aW9uX3N0b3JlLCBjb2xvcj1kZW1vZ3JhcGhpY19nZW5kZXIpKSArIGdlb21fcG9pbnQoKQpgYGAKCmBgYHtyfQpnZ3Bsb3QoZGF0YT1kZiwgYWVzKHg9aWQsIHk9YmVoYXZpb3VyX2luZG9vcnNfbm9uaG91c2Vob2xkZXJzLCBjb2xvcj1kZW1vZ3JhcGhpY19nZW5kZXIpKSArIGdlb21fcG9pbnQoKQpgYGAKCmBgYHtyfQpkZWNfbW9kCmBgYAoKYGBge3J9CmRlY19tb2QkYmVzdFR1bmUKZGVjX21vZCRmaW5hbE1vZGVsCmBgYAoK